#lang scheme

(provide dotimes
         vector-first
         vector-second
         vector-third
         vector-fourth
         vector-fifth
         vector-sixth
         vector-seventh
         vector-eighth
         vector-ninth
         vector-tenth
         vector-last
         for-pairs
         binary-search
         binary-search-3
         build-cumulative-vector
         port-size!
         port-size
         file-age
         mult-map ; TODO: cartesian-product-for-each
         create-mapping
         mapping-ref
         mapping-iref
         mapping-has?
         read-file ; file->bytes
         write-file
         inc!
         dec!
         pop!
         push!
         update!
         spawn
         define-mutable
         define-memo
         fst
         snd
         nth
         values-first
         values-second
         values-last
         values-ref
;         mlambda mlambda*
         try
         try-n-times
         )

(define (try proc)
  (with-handlers ([exn? (const #f)])
    (proc)
    #t))

(define (try-n-times n proc)
  (cond [(= 0 n) #f]
        [(= 1 n) (proc)] ; exception can raise
        [else    (with-handlers ([exn? (lambda(_)(try-n-times (sub1 n) proc))])
                   (proc))]))


(define fst (lambda args (first args)))
(define snd (lambda args (second args)))
(define (nth n) (lambda args (list-ref args n)))

(define-syntax values-first
  (syntax-rules ()
    ((_ x)
     (call-with-values (lambda () x) (lambda args (first args))))))

(define-syntax values-second
  (syntax-rules ()
    ((_ x)
     (call-with-values (lambda () x) (lambda args (second args))))))

(define-syntax values-last
  (syntax-rules ()
    ((_ x)
     (call-with-values (lambda () x) (lambda args (last args))))))

(define-syntax values-ref
  (syntax-rules ()
    ((_ x n)
     (call-with-values (lambda () x) (lambda args (list-ref args n))))))

(equal! (fst 1 2) 1)
(equal! ((nth 2) 'a 'b 'c 'd) 'c)
(equal! (values-first (values 'a 'b 'c 'd 'e)) 'a)
(equal! (values-ref (values 'a 'b 'c 'd 'e) 3) 'd)

(define-syntax spawn
  (syntax-rules ()
    [(_ body ...)
     (thread (lambda () body ...))]))

; (define-mutable (handle1)
;  (void))
; Now, it is possible to change it from REPL:
; (set! handle +)
(define-syntax define-mutable
  (syntax-rules ()
    [(_ (name args ...) body ...)
     (begin (define name #f)
            (set! name (lambda (args ...) body ...)))]
    [(_ name body ...)
     (begin (define name #f)
            (set! name body ...))]))


; (row2) - calcs each time
;(define (row2) (current-seconds))
; (row3) - calcs once and remembers the result forever
;(define-memo (row3) (current-seconds))
(define-syntax define-memo
  (syntax-rules ()
    [(_ (name) body ...)
     (define (name)
       (let ([v body ...])
         (set! name (const v))
         v))]))


;(require srfi/17)
;(define-syntax inc!     ; Mutable increment
;  (syntax-rules ()
;    ((inc! x) (set! x (+ 1 x)))))

;(define-syntax dec!     ; Mutable decrement
;  (syntax-rules ()
;    ((dec! x) (set! x (- x 1)))))
(define-syntax inc!
  (syntax-rules ()
    [(_ "vars" ((var arg) ...) () proc num)
     (let ((getter proc)
           (delta num)
           (var arg) ...)
       (let ((val (getter var ...)))
         ((setter getter) var ... (+ val delta))))]
    [(_ "vars" ((var arg) ...) (arg0 arg1 ...) proc num)
     (inc! "vars" ((var arg) ... (newvar arg0)) (arg1 ...) proc num)]
    [(_ (proc arg ...) num)
     (inc! "vars" () (arg ...) proc num)]
    [(_ (proc arg ...))
     (inc! "vars" () (arg ...) proc 1)]
    [(_ loc num)
     (let ((val loc))
       (set! loc (+ val num)))]
    [(_ loc)
     (inc! loc 1)]
    [(_ . other)
     (syntax-error "malformed inc!" (inc! . other))]))

(define-syntax dec!
  (syntax-rules ()
    [(_ "vars" ((var arg) ...) () proc num)
     (let ((getter proc)
           (delta num)
           (var arg) ...)
       (let ((val (getter var ...)))
         ((setter getter) var ... (- val delta))))]
    [(_ "vars" ((var arg) ...) (arg0 arg1 ...) proc num)
     (dec! "vars" ((var arg) ... (newvar arg0)) (arg1 ...) proc num)]
    [(_ (proc arg ...) num)
     (dec! "vars" () (arg ...) proc num)]
    [(_ (proc arg ...))
     (dec! "vars" () (arg ...) proc 1)]
    [(_ loc num)
     (let ((val loc))
       (set! loc (- val num)))]
    [(_ loc)
     (dec! loc 1)]
    [(_ . other)
     (syntax-error "malformed dec!" (dec! . other))]))

(define-syntax update!
  (syntax-rules ()
    [(_ "vars" ((var arg) ...) () proc updater val ...)
     (let ((getter proc)
           (var arg) ...)
       ((setter getter) var ... (updater val ... (getter var ...))))]
    [(_ "vars" ((var arg) ...) (arg0 arg1 ...) proc updater val ...)
     (update! "vars"
              ((var arg) ... (newvar arg0))
              (arg1 ...)
              proc updater val ...)]
    [(_ (proc arg ...) updater val ...)
     (update! "vars"
              ()
              (arg ...)
              proc updater val ...)]
    [(_ loc updater val ...)
     (set! loc (updater val ... loc))]
    [(_ . other)
     (syntax-error "malformed update!" (update! . other))]))


(define-syntax push!
  (syntax-rules ()
    [(_ "vars" ((var arg) ...) () proc val)
     (let ((getter proc)
           (var arg) ...)
       ((setter getter) var ... (cons val (getter var ...))))]
    [(_ "vars" ((var arg) ...) (arg0 arg1 ...) proc val)
     (push! "vars" ((var arg) ... (newvar arg0)) (arg1 ...) proc val)]
    [(_ (proc arg ...) val)
     (push! "vars" () (arg ...) proc val)]
    [(_ loc val)
     (set! loc (cons val loc))]
    [(_ . other)
     (syntax-error "malformed push!" (push! . other))]))

(define-syntax pop!
  (syntax-rules ()
    [(_ "vars" ((var arg) ...) () proc)
     (let ((getter proc)
           (var arg) ...)
       (let ((val (getter var ...)))
         ((setter getter) var ... (cdr val))
         (car val)))]
    [(_ "vars" ((var arg) ...) (arg0 arg1 ...) proc)
     (pop! "vars" ((var arg) ... (newvar arg0)) (arg1 ...) proc)]
    [(_ (proc arg ...))
     (pop! "vars" () (arg ...) proc)]
    [(_ loc)
     (let ((val loc))
       (set! loc (cdr val))
       (car val))]
    [(_ . other)
     (syntax-error "malformed pop!" (pop! . other))]))


(define (read-file path [n (file-size path)])
  (call-with-input-file
      path
    (lambda(p)
      (read-bytes n p))))


(define (write-file path bstr)
  (call-with-output-file
      path
    (lambda(p) (write-bytes bstr p))))

; (import (rnrs))
(define-syntax dotimes
  (syntax-rules ()
    ((_ (i e1) e2 e3 ...)
     (let ((n e1))
       (let loop ((i 0))
         (when (< i n)
           (begin
             e2 e3 ...
             (loop (+ i 1)))))))
    ((_ n e1 e2 ...)
     (let loop ((i n))
       (when (> i 0)
         (begin
           e1 e2 ...
           (loop (- i 1))))))))

(define (vector-first   v) (vector-ref v 0))
(define (vector-second  v) (vector-ref v 1))
(define (vector-third   v) (vector-ref v 2))
(define (vector-fourth  v) (vector-ref v 3))
(define (vector-fifth   v) (vector-ref v 4))
(define (vector-sixth   v) (vector-ref v 5))
(define (vector-seventh v) (vector-ref v 6))
(define (vector-eighth  v) (vector-ref v 7))
(define (vector-ninth   v) (vector-ref v 8))
(define (vector-tenth   v) (vector-ref v 9))
(define (vector-last    v) (vector-ref v (- (vector-length v) 1)))

; take all pairs
(define (for-pairs lst proc)
  ;  (let ([len (vector-length v)]
  ;  (do
  (foldr
   (lambda (a l1)
     (cons
      (foldr
       (lambda (b l) (cons (proc a b) l))
       '() lst) l1))
   '() lst))


; file position set to the eof
(define (port-size! p)
  (file-position p eof)
  (file-position p))

; restore file position
(define (port-size p)
  (let ([saved-pos (file-position p)])
    (file-position p eof)
    (let ([size (file-position p)])
      (file-position p saved-pos)
      size)))

;; string -> number
(define (file-age path)
  (if (file-exists? path)
      (- (current-seconds)
         (file-or-directory-modify-seconds path))
      -1))

(define (binary-search-3 min
                         max ; index will be min..max-1
                         cmp) ; index -> -1|0|1
  (let loop ([start min]
             [end max])
    (if (= start end)
        (cond [(zero? start) (values #f 0)] ; (values 'smallest #f)
              [(= start max) (values #f max)] ; (values 'greatest #f)
              [else (values #f start)]) ; (values 'before start 1)
        (let* ([i (quotient (+ start end) 2)]
               [comparison (cmp i)])
          (cond [(zero?     comparison) (values #t i)]
                [(positive? comparison) (loop start i)]
                [else                   (loop (add1 i) end)])))))

; return min..max
(define (binary-search min
                       max ; index will be min..max-1
                       less) ; f(index) < key
  (let loop ([start min]
             [end max])
    (if (= start end)
        start
        (let ([i (quotient (+ start end) 2)])
          (if (less i)
              (loop (add1 i) end)
              (loop start i))))))

;; (build-cumulative-vector 2 p) makes '(0 (p 0) (+(p 0)(p 1)))
; useful for binary search later
(define (build-cumulative-vector len proc)
  (let ([v (make-vector (add1 len))])
    (let loop ([i 0] [sum 0])
      (vector-set! v i sum)
      (if (< i len)
          (loop (add1 i) (+ sum (proc i)))
          v))))


(require "test.ss")
(=! 0 (binary-search 0 5 (lambda (i) (< i -1))))
(=! 0 (binary-search 0 5 (lambda (i) (< i 0))))
(=! 1 (binary-search 0 5 (lambda (i) (< i 1))))
(=! 2 (binary-search 0 5 (lambda (i) (< i 2))))
(=! 3 (binary-search 0 5 (lambda (i) (< i 3))))
(=! 4 (binary-search 0 5 (lambda (i) (< i 4))))
(=! 5 (binary-search 0 5 (lambda (i) (< i 5))))
(=! 5 (binary-search 0 5 (lambda (i) (< i 6))))

;(build-vector 5 (lambda(i) (+ 10 i)) )
(equal! (build-cumulative-vector 5 (lambda(i) (+ 10 i)) ) #(0 10 21 33 46 60) )
(equal! (build-cumulative-vector 5 (lambda(i) 1) ) #(0 1 2 3 4 5) )

; TODO: remove in favor of cartesian-product-for-each
(define (mult-map proc . lists)
  (let loop ([init '()]
             [lists lists]
             [params '()])
    (if (null? lists)
        (cons (apply proc params) init)
        (foldl ; foldr
         (lambda (zone init) (loop init (cdr lists) (cons zone params)))
         init
         (car lists)))))

(=! 36 (length (mult-map
                (lambda (zone d) (bytes-append d #"." zone))
                '(#"COM" #"GOV" #"MIL" #"EDU" #"NET" #"ORG" #"INT" #"BIZ" #"INFO" #"CO" #"NE" #"AC" )
                '(#"RU" #"WS" #"UA"))))


(require srfi/43)
; vector with fast reverse (content -> index)
(define-struct mapping (>vector   ; num->val
                        >hash)  ; val->num
  #:transparent)

(define (create-mapping vec)
  (let ([hash (make-hash)])
    (vector-for-each (lambda (i item) (hash-set! hash item i)) vec)
    (make-mapping vec hash)))

(define (mapping-ref m i)
  (vector-ref (mapping->vector m) i))

(define (mapping-iref m v)
  (hash-ref (mapping->hash m) v))

(define (mapping-has? m v)
  (hash-has-key? (mapping->hash m) v))
